home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / LWP / UserAgent.pm < prev   
Encoding:
Perl POD Document  |  1999-12-28  |  21.4 KB  |  771 lines
  1.  
  2. package LWP::UserAgent;
  3.  
  4.  
  5. =head1 NAME
  6.  
  7. LWP::UserAgent - A WWW UserAgent class
  8.  
  9. =head1 SYNOPSIS
  10.  
  11.  require LWP::UserAgent;
  12.  $ua = new LWP::UserAgent;
  13.  
  14.  $request = new HTTP::Request('GET', 'file://localhost/etc/motd');
  15.  
  16.  $response = $ua->request($request); # or
  17.  $response = $ua->request($request, '/tmp/sss'); # or
  18.  $response = $ua->request($request, \&callback, 4096);
  19.  
  20.  sub callback { my($data, $response, $protocol) = @_; .... }
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. The C<LWP::UserAgent> is a class implementing a simple World-Wide Web
  25. user agent in Perl. It brings together the HTTP::Request,
  26. HTTP::Response and the LWP::Protocol classes that form the rest of the
  27. core of libwww-perl library. For simple uses this class can be used
  28. directly to dispatch WWW requests, alternatively it can be subclassed
  29. for application-specific behaviour.
  30.  
  31. In normal usage the application creates a UserAgent object, and then
  32. configures it with values for timeouts proxies, name, etc. The next
  33. step is to create an instance of C<HTTP::Request> for the request that
  34. needs to be performed. This request is then passed to the UserAgent
  35. request() method, which dispatches it using the relevant protocol,
  36. and returns a C<HTTP::Response> object.
  37.  
  38. The basic approach of the library is to use HTTP style communication
  39. for all protocol schemes, i.e. you will receive an C<HTTP::Response>
  40. object also for gopher or ftp requests.  In order to achieve even more
  41. similarities with HTTP style communications, gopher menus and file
  42. directories will be converted to HTML documents.
  43.  
  44. The request() method can process the content of the response in one of
  45. three ways: in core, into a file, or into repeated calls of a
  46. subroutine.  You choose which one by the kind of value passed as the
  47. second argument to request().
  48.  
  49. The in core variant simply returns the content in a scalar attribute
  50. called content() of the response object, and is suitable for small
  51. HTML replies that might need further parsing.  This variant is used if
  52. the second argument is missing (or is undef).
  53.  
  54. The filename variant requires a scalar containing a filename as the
  55. second argument to request(), and is suitable for large WWW objects
  56. which need to be written directly to the file, without requiring large
  57. amounts of memory. In this case the response object returned from
  58. request() will have empty content().  If the request fails, then the
  59. content() might not be empty, and the file will be untouched.
  60.  
  61. The subroutine variant requires a reference to callback routine as the
  62. second argument to request() and it can also take an optional chuck
  63. size as third argument.  This variant can be used to construct
  64. "pipe-lined" processing, where processing of received chuncks can
  65. begin before the complete data has arrived.  The callback function is
  66. called with 3 arguments: the data received this time, a reference to
  67. the response object and a reference to the protocol object.  The
  68. response object returned from request() will have empty content().  If
  69. the request fails, then the the callback routine will not have been
  70. called, and the response->content() might not be empty.
  71.  
  72. The request can be aborted by calling die() within the callback
  73. routine.  The die message will be available as the "X-Died" special
  74. response header field.
  75.  
  76. The library also accepts that you put a subroutine reference as
  77. content in the request object.  This subroutine should return the
  78. content (possibly in pieces) when called.  It should return an empty
  79. string when there is no more content.
  80.  
  81. The user of this module can finetune timeouts and error handling by
  82. calling the use_alarm() and use_eval() methods.
  83.  
  84. By default the library uses alarm() to implement timeouts, dying if
  85. the timeout occurs. If this is not the prefered behaviour or it
  86. interferes with other parts of the application one can disable the use
  87. alarms. When alarms are disabled timeouts can still occur for example
  88. when reading data, but other cases like name lookups etc will not be
  89. timed out by the library itself.
  90.  
  91. The library catches errors (such as internal errors and timeouts) and
  92. present them as HTTP error responses. Alternatively one can switch off
  93. this behaviour, and let the application handle dies.
  94.  
  95. =head1 SEE ALSO
  96.  
  97. See L<LWP> for a complete overview of libwww-perl5.  See L<request> and
  98. L<mirror> for examples of usage.
  99.  
  100. =head1 METHODS
  101.  
  102. =cut
  103.  
  104.  
  105.  
  106. require LWP::MemberMixin;
  107. @ISA = qw(LWP::MemberMixin);
  108.  
  109. require URI::URL;
  110. require HTTP::Request;
  111. require HTTP::Response;
  112.  
  113. use HTTP::Date ();
  114.  
  115. use LWP ();
  116. use LWP::Debug ();
  117. use LWP::Protocol ();
  118.  
  119. use MIME::Base64 qw(encode_base64);
  120. use Carp ();
  121. use Config ();
  122.  
  123. use AutoLoader ();
  124. *AUTOLOAD = \&AutoLoader::AUTOLOAD;  # import the AUTOLOAD method
  125.  
  126.  
  127. =head2 $ua = new LWP::UserAgent;
  128.  
  129. Constructor for the UserAgent.  Returns a reference to a
  130. LWP::UserAgent object.
  131.  
  132. =cut
  133.  
  134. sub new
  135. {
  136.     my($class, $init) = @_;
  137.     LWP::Debug::trace('()');
  138.  
  139.     my $self;
  140.     if (ref $init) {
  141.     $self = $init->clone;
  142.     } else {
  143.     $self = bless {
  144.         'agent'       => "libwww-perl/$LWP::VERSION",
  145.         'from'        => undef,
  146.         'timeout'     => 3*60,
  147.         'proxy'       => undef,
  148.         'use_eval'    => 1,
  149.         'use_alarm'   => ($Config::Config{d_alarm} ?
  150.                   $Config::Config{d_alarm} eq 'define' :
  151.                   0),
  152.                 'parse_head'  => 1,
  153.                 'max_size'    => undef,
  154.         'no_proxy'    => [],
  155.     }, $class;
  156.     }
  157. }
  158.  
  159.  
  160. =head2 $ua->simple_request($request, [$arg [, $size]])
  161.  
  162. This method dispatches a single WWW request on behalf of a user, and
  163. returns the response received.  The C<$request> should be a reference
  164. to a C<HTTP::Request> object with values defined for at least the
  165. method() and url() attributes.
  166.  
  167. If C<$arg> is a scalar it is taken as a filename where the content of
  168. the response is stored.
  169.  
  170. If C<$arg> is a reference to a subroutine, then this routine is called
  171. as chunks of the content is received.  An optional C<$size> argument
  172. is taken as a hint for an appropriate chunk size.
  173.  
  174. If C<$arg> is omitted, then the content is stored in the response
  175. object itself.
  176.  
  177. =cut
  178.  
  179. sub simple_request
  180. {
  181.     my($self, $request, $arg, $size) = @_;
  182.     local($SIG{__DIE__});  # protect agains user defined die handlers
  183.  
  184.     my($method, $url) = ($request->method, $request->url);
  185.  
  186.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, "Method missing")
  187.     unless $method;
  188.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, "URL missing")
  189.     unless $url;
  190.  
  191.     LWP::Debug::trace("$method $url");
  192.  
  193.     my $scheme = '';
  194.     my $proxy = $self->_need_proxy($url);
  195.     if (defined $proxy) {
  196.     $scheme = $proxy->scheme;
  197.     } else {
  198.     $scheme = $url->scheme;
  199.     }
  200.     my $protocol;
  201.     eval {
  202.     $protocol = LWP::Protocol::create($scheme);
  203.     };
  204.     if ($@) {
  205.     $@ =~ s/\s+at\s+\S+\s+line\s+\d+//;  # remove file/line number
  206.     return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED, $@)
  207.     }
  208.  
  209.     my ($agent, $from, $timeout, $use_alarm, $use_eval, $parse_head, $max_size) =
  210.       @{$self}{qw(agent from timeout use_alarm use_eval parse_head max_size)};
  211.  
  212.     $request->header('User-Agent' => $agent) if $agent;
  213.     $request->header('From' => $from) if $from;
  214.  
  215.     $protocol->use_alarm($use_alarm);
  216.     $protocol->parse_head($parse_head);
  217.     $protocol->max_size($max_size);
  218.     
  219.     if ($use_alarm) {
  220.     $SIG{'ALRM'} = sub {
  221.         LWP::Debug::trace('timeout');
  222.         die 'Timeout';
  223.     };
  224.     $protocol->timeout($timeout);
  225.     alarm($timeout);
  226.     }
  227.  
  228.     if ($use_eval) {
  229.     eval {
  230.         $response = $protocol->request($request, $proxy,
  231.                        $arg, $size, $timeout);
  232.     };
  233.     if ($@) {
  234.         if ($@ =~ /^timeout/i) {
  235.         $response = HTTP::Response->new(&HTTP::Status::RC_REQUEST_TIMEOUT, 'User-agent timeout');
  236.         } else {
  237.         $@ =~ s/\s+at\s+\S+\s+line\s+\d+\s*//;  # remove file/line number
  238.         $response = HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@);
  239.         }
  240.     }
  241.     } else {
  242.     $response = $protocol->request($request, $proxy,
  243.                        $arg, $size, $timeout);
  244.     }
  245.     alarm(0) if ($use_alarm); # no more timeout
  246.  
  247.     $response->request($request);  # record request for reference
  248.     $response->header("Client-Date" => HTTP::Date::time2str(time));
  249.     return $response;
  250. }
  251.  
  252.  
  253. =head2 $ua->request($request, $arg [, $size])
  254.  
  255. Process a request, including redirects and security.  This method may
  256. actually send several different simple reqeusts.
  257.  
  258. The arguments are the same as for C<simple_request()>.
  259.  
  260. =cut
  261.  
  262. sub request
  263. {
  264.     my($self, $request, $arg, $size, $previous) = @_;
  265.  
  266.     LWP::Debug::trace('()');
  267.  
  268.     my $response = $self->simple_request($request, $arg, $size);
  269.  
  270.     my $code = $response->code;
  271.     $response->previous($previous) if defined $previous;
  272.  
  273.     LWP::Debug::debug('Simple result: ' . HTTP::Status::status_message($code));
  274.  
  275.     if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
  276.     $code == &HTTP::Status::RC_MOVED_TEMPORARILY) {
  277.  
  278.     my $referral = $request->clone;
  279.  
  280.     my $referral_uri = (URI::URL->new($response->header('Location'),
  281.                       $response->base))->abs();
  282.  
  283.     $referral->url($referral_uri);
  284.  
  285.     return $response unless $self->redirect_ok($referral);
  286.  
  287.     my $r = $response;
  288.     while ($r) {
  289.         if ($r->request->url->as_string eq $referral_uri->as_string) {
  290.         $response->message("Loop detected");
  291.         return $response;
  292.         }
  293.         $r = $r->previous;
  294.     }
  295.  
  296.     return $self->request($referral, $arg, $size, $response);
  297.  
  298.     } elsif ($code == &HTTP::Status::RC_UNAUTHORIZED) {
  299.  
  300.     my $challenge = $response->header('WWW-Authenticate');
  301.     unless (defined $challenge) {
  302.         warn "RC_UNAUTHORIZED without WWW-Authenticate\n";
  303.         return $response;
  304.     }
  305.     if (($challenge =~ /^(\S+)\s+Realm\s*=\s*"(.*?)"/i) or
  306.         ($challenge =~ /^(\S+)\s+Realm\s*=\s*<([^<>]*)>/i) or
  307.         ($challenge =~ /^(\S+)$/)
  308.         ) {
  309.  
  310.         my($scheme, $realm) = ($1, $2);
  311.         if ($scheme =~ /^Basic$/i) {
  312.  
  313.         my($uid, $pwd) = $self->get_basic_credentials($realm,
  314.                                 $request->url);
  315.  
  316.         if (defined $uid and defined $pwd) {
  317.             my $uidpwd = "$uid:$pwd";
  318.             my $header = "$scheme " . encode_base64($uidpwd, '');
  319.  
  320.             my $r = $response;
  321.             while ($r) {
  322.             my $auth = $r->request->header('Authorization');
  323.             if ($auth && $auth eq $header) {
  324.                 $response->message('Invalid Credentials');
  325.                 return $response;
  326.             }
  327.             $r = $r->previous;
  328.             }
  329.  
  330.             my $referral = $request->clone;
  331.             $referral->header('Authorization' => $header);
  332.  
  333.             return $self->request($referral, $arg, $size, $response);
  334.         } else {
  335.             return $response; # no password found
  336.         }
  337.         } elsif ($scheme =~ /^Digest$/i) {
  338.         require MD5;
  339.         my $md5 = new MD5;
  340.         my($uid, $pwd) = $self->get_basic_credentials($realm,
  341.                                   $request->url);
  342.         my $string = $challenge;
  343.         $string =~ s/^$scheme\s+//;
  344.         $string =~ s/"//g;                       #" unconfuse emacs
  345.         my %mda = map { split(/,?\s+|=/) } $string;
  346.  
  347.         my(@digest);
  348.         $md5->add(join(":", $uid, $mda{realm}, $pwd));
  349.         push(@digest, $md5->hexdigest);
  350.         $md5->reset;
  351.  
  352.         push(@digest, $mda{nonce});
  353.  
  354.         $md5->add(join(":", $request->method, $request->url->path));
  355.         push(@digest, $md5->hexdigest);
  356.         $md5->reset;
  357.  
  358.         $md5->add(join(":", @digest));
  359.         my($digest) = $md5->hexdigest;
  360.         $md5->reset;
  361.  
  362.         my %resp = map { $_ => $mda{$_} } qw(realm nonce opaque);
  363.         @resp{qw(username uri response)} =
  364.           ($uid, $request->url->path, $digest);
  365.  
  366.         if (defined $uid and defined $pwd) {
  367.             my(@order) = qw(username realm nonce uri response);
  368.             if($request->method =~ /^(?:POST|PUT)$/) {
  369.             $md5->add($request->content);
  370.             my($content) = $md5->hexdigest;
  371.             $md5->reset;
  372.             $md5->add(join(":", @digest[0..1], $content));
  373.             $md5->reset;
  374.             $resp{"message-digest"} = $md5->hexdigest;
  375.             push(@order, "message-digest");
  376.             }
  377.             push(@order, "opaque");
  378.             my @pairs;
  379.             for (@order) {
  380.             next unless defined $resp{$_};
  381.             push(@pairs, "$_=" . qq("$resp{$_}"));
  382.             }
  383.             my $header = "$scheme " . join(", ", @pairs);
  384.  
  385.             my $r = $response;
  386.             while ($r) {
  387.             my $auth = $r->request->header('Authorization');
  388.             if ($auth && $auth eq $header) {
  389.                 $response->message('Invalid Credentials');
  390.                 return $response;
  391.             }
  392.             $r = $r->previous;
  393.             }
  394.  
  395.             my $referral = $request->clone;
  396.             $referral->header('Authorization' => $header);
  397.             return $self->request($referral, $arg, $size, $response);
  398.         } else {
  399.             return $response; # no password found
  400.         }
  401.         } else {
  402.         my $class = "LWP::Authen::$scheme";
  403.         eval "use $class ()";
  404.         if($@) {
  405.             warn $@;
  406.             warn "Authentication scheme '$scheme' not supported\n";
  407.             return $response;
  408.         }
  409.         return $class->authenticate($self, $response, $request, $arg, $size, $scheme, $realm);
  410.         } 
  411.     } else {
  412.         warn "Unknown challenge '$challenge'";
  413.         return $response;
  414.     }
  415.  
  416.     } elsif ($code == &HTTP::Status::RC_PAYMENT_REQUIRED or
  417.          $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED) {
  418.     warn 'Resolution of' . HTTP::Status::status_message($code) .
  419.          'not yet implemented';
  420.     return $response;
  421.     }
  422.     $response;
  423. }
  424.  
  425.  
  426. =head2 $ua->redirect_ok
  427.  
  428. This method is called by request() before it tries to do any
  429. redirects.  It should return a true value if the redirect is allowed
  430. to be performed. Subclasses might want to override this.
  431.  
  432. The default implementation will return FALSE for POST request and TRUE
  433. for all others.
  434.  
  435. =cut
  436.  
  437. sub redirect_ok
  438. {
  439.  
  440.     my($self, $request) = @_;
  441.     return 0 if $request->method eq "POST";
  442.     1;
  443. }
  444.  
  445.  
  446. =head2 $ua->credentials($netloc, $realm, $uname, $pass)
  447.  
  448. Set the user name and password to be used for a realm.  It is often more
  449. useful to specialize the get_basic_credentials() method instead.
  450.  
  451. =cut
  452.  
  453. sub credentials
  454. {
  455.     my($self, $netloc, $realm, $uid, $pass) = @_;
  456.     @{ $self->{'basic_authentication'}{$netloc}{$realm} } = ($uid, $pass);
  457. }
  458.  
  459.  
  460. =head2 $ua->get_basic_credentials($realm, $uri)
  461.  
  462. This is called by request() to retrieve credentials for a Realm
  463. protected by Basic Authentication or Digest Authentication.
  464.  
  465. Should return username and password in a list.  Return undef to abort
  466. the authentication resolution atempts.
  467.  
  468. This implementation simply checks a set of pre-stored member
  469. variables. Subclasses can override this method to e.g. ask the user
  470. for a username/password.  An example of this can be found in
  471. C<lwp-request> program distributed with this library.
  472.  
  473. =cut
  474.  
  475. sub get_basic_credentials
  476. {
  477.     my($self, $realm, $uri) = @_;
  478.     my $netloc = $uri->netloc;
  479.  
  480.     if (exists $self->{'basic_authentication'}{$netloc}{$realm}) {
  481.     return @{ $self->{'basic_authentication'}{$netloc}{$realm} };
  482.     }
  483.  
  484.     return (undef, undef);
  485. }
  486.  
  487.  
  488. =head2 $ua->agent([$product_id])
  489.  
  490. Get/set the product token that is used to identify the user agent on
  491. the network.  The agent value is sent as the "User-Agent" header in
  492. the requests. The default agent name is "libwww-perl/#.##", where
  493. "#.##" is substitued with the version numer of this library.
  494.  
  495. The user agent string should be one or more simple product identifiers
  496. with an optional version number separated by the "/" character.
  497. Examples are:
  498.  
  499.   $ua->agent('Checkbot/0.4 ' . $ua->agent);
  500.   $ua->agent('Mozilla/5.0');
  501.  
  502. =head2 $ua->from([$email_address])
  503.  
  504. Get/set the Internet e-mail address for the human user who controls
  505. the requesting user agent.  The address should be machine-usable, as
  506. defined in RFC 822.  The from value is send as the "From" header in
  507. the requests.  There is no default.  Example:
  508.  
  509.   $ua->from('aas@sn.no');
  510.  
  511. =head2 $ua->timeout([$secs])
  512.  
  513. Get/set the timeout value in seconds. The default timeout() value is
  514. 180 seconds, i.e. 3 minutes.
  515.  
  516. =head2 $ua->use_alarm([$boolean])
  517.  
  518. Get/set a value indicating wether to use alarm() when implementing
  519. timeouts.  The default is TRUE, if your system supports it.  You can
  520. disable it if it interfers with other uses of alarm in your application.
  521.  
  522. =head2 $ua->use_eval([$boolean])
  523.  
  524. Get/set a value indicating wether to handle internal errors internally
  525. by trapping with eval.  The default is TRUE, i.e. the $ua->request()
  526. will never die.
  527.  
  528. =head2 $ua->parse_head([$boolean])
  529.  
  530. Get/set a value indicating wether we should initialize response
  531. headers from the E<lt>head> section of HTML documents. The default is
  532. TRUE.  Do not turn this off, unless you know what you are doing.
  533.  
  534. =head2 $ua->max_size([$bytes])
  535.  
  536. Get/set the size limit for response content.  The default is undef,
  537. which means that there is not limit.  If the returned response content
  538. is only partial, because the size limit was exceeded, then a
  539. "X-Content-Range" header will be added to the response.
  540.  
  541. =cut
  542.  
  543. sub timeout    { shift->_elem('timeout',   @_); }
  544. sub agent      { shift->_elem('agent',     @_); }
  545. sub from       { shift->_elem('from',      @_); }
  546. sub use_alarm  { shift->_elem('use_alarm', @_); }
  547. sub use_eval   { shift->_elem('use_eval',  @_); }
  548. sub parse_head { shift->_elem('parse_head',@_); }
  549. sub max_size   { shift->_elem('max_size',  @_); }
  550.  
  551.  
  552. sub clone;
  553. sub is_protocol_supported;
  554. sub mirror;
  555. sub proxy;
  556. sub env_proxy;
  557. sub no_proxy;
  558. sub _need_proxy;
  559.  
  560.  
  561. 1;
  562. __END__
  563.  
  564.  
  565. =head2 $ua->clone;
  566.  
  567. Returns a copy of the LWP::UserAgent object
  568.  
  569. =cut
  570.  
  571.  
  572. sub clone
  573. {
  574.     my $self = shift;
  575.     my $copy = bless { %$self }, ref $self;  # copy most fields
  576.  
  577.     $copy->{'no_proxy'} = [ @{$self->{'no_proxy'}} ];  # copy array
  578.  
  579.     $copy;
  580. }
  581.  
  582.  
  583. =head2 $ua->is_protocol_supported($scheme)
  584.  
  585. You can use this method to query if the library currently support the
  586. specified C<scheme>.  The C<scheme> might be a string (like 'http' or
  587. 'ftp') or it might be an URI::URL object reference.
  588.  
  589. =cut
  590.  
  591. sub is_protocol_supported
  592. {
  593.     my($self, $scheme) = @_;
  594.     if (ref $scheme) {
  595.     $scheme = $scheme->abs->scheme;
  596.     } else {
  597.     Carp::croak("Illeal scheme '$scheme' passed to is_protocol_supported")
  598.         if $scheme =~ /\W/;
  599.     $scheme = lc $scheme;
  600.     }
  601.     return LWP::Protocol::implementor($scheme);
  602. }
  603.  
  604.  
  605. =head2 $ua->mirror($url, $file)
  606.  
  607. Get and store a document identified by a URL, using If-Modified-Since,
  608. and checking of the Content-Length.  Returns a reference to the
  609. response object.
  610.  
  611. =cut
  612.  
  613. sub mirror
  614. {
  615.     my($self, $url, $file) = @_;
  616.  
  617.     LWP::Debug::trace('()');
  618.     my $request = new HTTP::Request('GET', $url);
  619.  
  620.     if (-e $file) {
  621.     my($mtime) = (stat($file))[9];
  622.     if($mtime) {
  623.         $request->header('If-Modified-Since' =>
  624.                  HTTP::Date::time2str($mtime));
  625.     }
  626.     }
  627.     my $tmpfile = "$file-$$";
  628.  
  629.     my $response = $self->request($request, $tmpfile);
  630.     if ($response->is_success) {
  631.  
  632.     my $file_length = (stat($tmpfile))[7];
  633.     my($content_length) = $response->header('Content-length');
  634.  
  635.     if (defined $content_length and $file_length < $content_length) {
  636.         unlink($tmpfile);
  637.         die "Transfer truncated: " .
  638.         "only $file_length out of $content_length bytes received\n";
  639.     } elsif (defined $content_length and $file_length > $content_length) {
  640.         unlink($tmpfile);
  641.         die "Content-length mismatch: " .
  642.         "expected $content_length bytes, got $file_length\n";
  643.     } else {
  644.         rename($tmpfile, $file) or
  645.         die "Cannot rename '$tmpfile' to '$file': $!\n";
  646.     }
  647.     } else {
  648.     unlink($tmpfile);
  649.     }
  650.     return $response;
  651. }
  652.  
  653. =head2 $ua->proxy(...)
  654.  
  655. Set/retrieve proxy URL for a scheme:
  656.  
  657.  $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/');
  658.  $ua->proxy('gopher', 'http://proxy.sn.no:8001/');
  659.  
  660. The first form specifies that the URL is to be used for proxying of
  661. access methods listed in the list in the first method argument,
  662. i.e. 'http' and 'ftp'.
  663.  
  664. The second form shows a shorthand form for specifying
  665. proxy URL for a single access scheme.
  666.  
  667. =cut
  668.  
  669. sub proxy
  670. {
  671.     my($self, $key, $proxy) = @_;
  672.  
  673.     LWP::Debug::trace("$key, $proxy");
  674.  
  675.     if (!ref($key)) {   # single scalar passed
  676.     my $old = $self->{'proxy'}{$key};
  677.     $self->{'proxy'}{$key} = $proxy;
  678.     return $old;
  679.     } elsif (ref($key) eq 'ARRAY') {
  680.     for(@$key) {    # array passed
  681.         $self->{'proxy'}{$_} = $proxy;
  682.     }
  683.     }
  684.     return undef;
  685. }
  686.  
  687. =head2 $ua->env_proxy()
  688.  
  689. Load proxy settings from *_proxy environment variables.  You might
  690. specify proxies like this (sh-syntax):
  691.  
  692.   gopher_proxy=http://proxy.my.place/
  693.   wais_proxy=http://proxy.my.place/
  694.   no_proxy="my.place"
  695.   export gopher_proxy wais_proxy no_proxy
  696.  
  697. Csh or tcsh users should use the C<setenv> command to define these
  698. envirionment variables.
  699.  
  700. =cut
  701.  
  702. sub env_proxy {
  703.     my ($self) = @_;
  704.     while(($k, $v) = each %ENV) {
  705.     $k = lc($k);
  706.     next unless $k =~ /^(.*)_proxy$/;
  707.     $k = $1;
  708.     if ($k eq 'no') {
  709.         $self->no_proxy(split(/\s*,\s*/, $v));
  710.     }
  711.     else {
  712.         $self->proxy($k, $v);
  713.     }
  714.     }
  715. }
  716.  
  717. =head2 $ua->no_proxy($domain,...)
  718.  
  719. Do not proxy requests to the given domains.  Calling no_proxy without
  720. any domains clears the list of domains. Eg:
  721.  
  722.  $ua->no_proxy('localhost', 'no', ...);
  723.  
  724. =cut
  725.  
  726. sub no_proxy {
  727.     my($self, @no) = @_;
  728.     if (@no) {
  729.     push(@{ $self->{'no_proxy'} }, @no);
  730.     }
  731.     else {
  732.     $self->{'no_proxy'} = [];
  733.     }
  734. }
  735.  
  736.  
  737. sub _need_proxy
  738. {
  739.     my($self, $url) = @_;
  740.  
  741.     $url = new URI::URL($url) unless ref $url;
  742.  
  743.     LWP::Debug::trace("($url)");
  744.  
  745.  
  746.     if (@{ $self->{'no_proxy'} }) {
  747.     my $host = $url->host;
  748.     return undef unless defined $host;
  749.     my $domain;
  750.     for $domain (@{ $self->{'no_proxy'} }) {
  751.         if ($host =~ /$domain$/) {
  752.         LWP::Debug::trace("no_proxy configured");
  753.         return undef;
  754.         }
  755.     }
  756.     }
  757.  
  758.  
  759.     my $scheme = $url->scheme;
  760.     if (exists $self->{'proxy'}{$scheme}) {
  761.  
  762.     LWP::Debug::debug('Proxied');
  763.     return new URI::URL($self->{'proxy'}{$scheme});
  764.     }
  765.  
  766.     LWP::Debug::debug('Not proxied');
  767.     undef;
  768. }
  769.  
  770. 1;
  771.